perm filename COPYIT.F4[XX,LCS]2 blob sn#182699 filedate 1975-10-19 generic text, type T, neo UTF8
00010	C***** COPYIT, UPDN, STFCH ****** (OUTLIM, GETPTS, MOVIT -ALL OLD)
06600	
06700		SUBROUTINE COPYIT
06750		INTEGER PWDS
06800		COMMON/XRN/RN(4000)  /KJY/ DONT,JY /POSI/S(8),JJ2,P
06900		COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
07000		1/PTR/PWDS(250),ITEM,LL,I,IX
07100		EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R7,RJQ(5))
07200		1,(R6,RJQ(4)),(N,RN(2500))
07300	
07400		IM=ITEM
07500		DO 1 K=1,IM
07600		L=PWDS(K)
07700		IF(RTLINE(L))GO TO 1
07800		IF(OUTLIM(L,3))GO TO 1
07900		IF(R6.NE.0.AND.R6.NE.RN(L+1))GO TO 1
08000		M=RN(L)+2
08100		CALL LOOP(0,M,1,I,L,RN)
08200		ITEM=ITEM+1
08300		L=PWDS(ITEM)
08400		RN(L+2)=R7
08500		IF(JJ2)JJ2=ITEM
08600		I=I+M+1
08700		PWDS(ITEM+1)=I
08800	1	CONTINUE
08900		R2=R7
09000		END
09100		SUBROUTINE STFCH
09110		INTEGER PWDS
09200		COMMON/XRN/RN(4000)  /KJY/ DONT,JY /POSI/S(8),JJ2,P
09300		COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
09400		1/PTR/PWDS(250),ITEM,LL,I,IX
09500		EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R7,RJQ(5))
09600		1,(R6,RJQ(4))
09700	
09800		DO 1 K=1,ITEM
09900		L=PWDS(K)
10000		IF(RTLINE(L))GO TO 1
10100		IF(OUTLIM(L,3))GO TO 1
10200		IF(RN(L+1).NE.R6.AND.R6.NE.0)GO TO 1
10300	C DIDN'T MATCH THE CODE NUM.
10350		IF(JJ2)JJ2=K
10400		RN(L+2)=R7
10500	1	CONTINUE
10600		END
10700	
10800		SUBROUTINE UPDN(NST)
10880		INTEGER PWDS
10900		COMMON/XRN/RN(4000)  /KJY/ DONT,JY /POSI/S(8),JJ2,P
11000		COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
11100		1/PTR/PWDS(250),ITEM,LL,I,IX
11200		EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R11,RJQ(9))
11300		1,(R6,RJQ(4))
11400	
11500		DO 1 K=NST,ITEM
11600		L=PWDS(K)
11700		IF(RTLINE(L))GO TO 1
11800		RY=RN(L+1)
11900		IF(RY.GT.16)GO TO 1
12000		IF(RY.EQ.8)GO TO 1
12100		IF(RY.EQ.3)GO TO 1
12200		IF(RY.EQ.R6)GO TO 10
12250		IF(R6.NE.0)GO TO 1
12300	C DIDN'T MATCH THE CODE NUM.
12400	10	IF(RY.NE.4)GO TO 11
12450		IF(RN(L).LT.3)GO TO 1
12500	C A BAR LINE
12600	11	IF(OUTLIM(L,3))GO TO 2
12650		RN(L+4)=RN(L+4)+R11
12675		IF(JJ2)JJ2=K
12700	2	IF(RY.LT.4)GO TO 1
12800		IF(RY.GT.7)GO TO 1
12900		IF(RY.EQ.7)GO TO 1 
13000	C NO WIGGLE ON TRILL
13100		IF(RY.NE.4.)GO TO 12
13150		IF(RN(L+5).EQ.50)GO TO 1
13200	C  CRESC. OR BOX
13300	12	IF(OUTLIM(L,6))GO TO 1
13350		RN(L+5)=RN(L+5)+R11
13360		IF(JJ2)JJ2=K
13400	1	CONTINUE
13500		END
13600	
15000	CF	SUBROUTINE GETPTS
15100	CF	DIMENSION N(500),NP(500)
15200	CF	COMMON/XRN/RN(4000)  /KJY/ K,J
15300	CF	COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
15400	CF	1/PTR/PWDS(250),ITEM,LL,I,IX
15500	CF	EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R11,RJQ(9))
15600	CF	1,(R6,RJQ(4)),(N,RN(2500)),(NP,RN(3000))
15700	CF	J=0
15800	CF	K=0
15900	CF	DO 1 M=1,ITEM
16000	CF	L=PWDS(M)
16100	CF	IF(RTLINE(L))GO TO 1
16200	CF	RY=RN(L+1)
16300	CF	IF(R6.LE.0)GO TO 9
16400	C  CHECK CODE NUM
16500	CF	IF(R6.NE.RY)GO TO 1
16600	CF9	IF(OUTLIM(R4,R5,RN(L+3)))GO TO 2
16700	C  IN LIMITS?
16800	CF	IF(JJ2)JJ2=M	**** ALSO AT 6,8 AND 5 ***
16900	CF	J=J+1
17000	CF	N(J)=L+3
17100	CF	K=K+1
17200	CF	NP(K)=L
17300	C  FOR USE IN JUSTIFY ROUTINE
17400	CF2	IF(RY.LT.4)GO TO 1
17500	CF	IF(RY.GT.7)GO TO 1
17600	C  TWO-ENDED ITEM?
17700	CF	RZ=RN(L)
17800	C  WD CNT
17900	CF	GO TO(4,5,6,7),IFIX(RY)-3
18000	CF4	IF(RZ.GT.2)GO TO 5
18100	CF	GO TO 1
18200	CF7	IF(RZ.GT.4)GO TO 5
18300	CF	GO TO 1
18400	CF6	IF(RZ.LT.8)GO TO 8
18500	CF	IF(RN(L+10).LT.30)GO TO 8
18600	CF	IF(OUTLIM(R4,R5,RN(L+8)))GO TO 8
18700	CF	J=J+1
18800	CF	N(J)=L+8
18900	CF	IF(RZ.LT.7)GO TO 5
19000	CF	IF(OUTLIM(R4,R5,RN(L+9)))GO TO 5
19100	CF	J=J+1
19200	CF	N(J)=L+9
19300	CF5	IF(OUTLIM(R4,R5,RN(L+6)))GO TO 1
19400	CF	J=J+1
19500	CF	N(J)=L+6
19600	CF1	CONTINUE
19700	CF	END
19800	
19900	CF	FUNCTION OUTLIM(A,B,C)
20000	CF	OUTLIM=-1
20100	CF	IF(C.LT.A)RETURN
20200	CF	IF(C.GT.B)RETURN
20300	CF	OUTLIM=0 
20400	CF	END
20500	CF	SUBROUTINE MOVIT
20600	CF	DIMENSION N(500)
20700	CF	COMMON/XRN/RN(4000)  /KJY/ DONT,J
20800	CF	COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
20900	CF	EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R9,RJQ(7))
21000	CF	1,(R6,RJQ(4)),(N,RN(2500)),(R8,RJQ(6))
21100	CF	RDIS=(R9-R8)/(R5-R4)
21200	CF	DO 1 K=1,J
21300	CF	L=N(K)
21400	CF	RA=RN(L)
21500	CF	IF(OUTLIM(R4,R5,RA))GO TO 1
21600	CF	IF(R9.NE.0)RA=(RA-R4)*RDIS
21700	CF	RN(L)=R8+RA
21800	CF1	CONTINUE
21900	CF	END